home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / seqtran.lisp < prev    next >
Encoding:
Text File  |  1992-12-09  |  14.9 KB  |  471 lines
  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: seqtran.lisp,v 1.16 92/08/05 00:36:42 wlott Locked $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    This file contains optimizers for list and sequence functions.
  15. ;;;
  16. ;;; Written by Rob MacLachlan.  Some code adapted from the old seqtran file,
  17. ;;; written by Wholey and Fahlman.
  18. ;;;
  19. (in-package 'c)
  20.  
  21.  
  22. (defun mapper-transform (fn arglists accumulate take-car)
  23.   (collect ((do-clauses)
  24.         (args-to-fn)
  25.         (tests))
  26.     (let ((n-first (gensym)))
  27.       (dolist (a (if accumulate
  28.              arglists
  29.              `(,n-first ,@(rest arglists))))
  30.     (let ((v (gensym)))
  31.       (do-clauses `(,v ,a (cdr ,v)))
  32.       (tests `(endp ,v))
  33.       (args-to-fn (if take-car `(car ,v) v))))
  34.       
  35.       (let ((call `(funcall ,fn . ,(args-to-fn)))
  36.         (endtest `(or ,@(tests))))
  37.     (ecase accumulate
  38.       (:nconc
  39.        (let ((temp (gensym))
  40.          (map-result (gensym)))
  41.          `(let ((,map-result (list nil)))
  42.         (do-anonymous ((,temp ,map-result) . ,(do-clauses))
  43.                   (,endtest (cdr ,map-result))
  44.           (setq ,temp (last (nconc ,temp ,call)))))))
  45.       (:list
  46.        (let ((temp (gensym))
  47.          (map-result (gensym)))
  48.          `(let ((,map-result (list nil)))
  49.         (do-anonymous ((,temp ,map-result) . ,(do-clauses))
  50.                   (,endtest (cdr ,map-result))
  51.           (rplacd ,temp (setq ,temp (list ,call)))))))
  52.       ((nil)
  53.        `(let ((,n-first ,(first arglists)))
  54.           (do-anonymous ,(do-clauses)
  55.                 (,endtest ,n-first) ,call))))))))
  56.  
  57. (def-source-transform mapc (function list &rest more-lists)
  58.   (mapper-transform function (cons list more-lists) nil t))
  59.  
  60. (def-source-transform mapcar (function list &rest more-lists)
  61.   (mapper-transform function (cons list more-lists) :list t))
  62.  
  63. (def-source-transform mapcan (function list &rest more-lists)
  64.   (mapper-transform function (cons list more-lists) :nconc t))
  65.  
  66. (def-source-transform mapl (function list &rest more-lists)
  67.   (mapper-transform function (cons list more-lists) nil nil))
  68.  
  69. (def-source-transform maplist (function list &rest more-lists)
  70.   (mapper-transform function (cons list more-lists) :list nil))
  71.  
  72. (def-source-transform mapcon (function list &rest more-lists)
  73.   (mapper-transform function (cons list more-lists) :nconc nil))
  74.  
  75. (deftransform elt ((s i) ((simple-array * (*)) *))
  76.   '(aref s i))
  77.  
  78. (deftransform elt ((s i) (list *))
  79.   '(nth i s))
  80.  
  81. (deftransform %setelt ((s i v) ((simple-array * (*)) * *))
  82.   '(%aset s i v))
  83.  
  84. (deftransform %setelt ((s i v) (list * *))
  85.   '(setf (car (nthcdr i s)) v))
  86.  
  87.  
  88. (deftransform member ((e l &key (test #'eql)) * * :node node)
  89.   (unless (constant-continuation-p l) (give-up))
  90.   
  91.   (let ((val (continuation-value l)))
  92.     (unless (policy node
  93.             (or (= speed 3)
  94.             (and (>= speed space)
  95.                  (<= (length val) 5))))
  96.       (give-up))
  97.     
  98.     (labels ((frob (els)
  99.            (if els
  100.            `(if (funcall test e ',(car els))
  101.             ',els
  102.             ,(frob (cdr els)))
  103.            'nil)))
  104.       (frob val))))
  105.  
  106. ;;; Names of predicates that compute the same value as CHAR= when applied to
  107. ;;; characters.
  108. ;;; 
  109. (defconstant char=-functions '(eql equal char=))
  110.  
  111.  
  112. (deftransform search ((string1 string2 &key (start1 0) end1 (start2 0) end2
  113.                    test)
  114.               (simple-string simple-string &rest t))
  115.   (unless (or (not test)
  116.           (continuation-function-is test char=-functions))
  117.     (give-up))
  118.   '(lisp::%sp-string-search string1 start1 (or end1 (length string1))
  119.                 string2 start2 (or end2 (length string2))))
  120.                   
  121. (deftransform position ((item sequence &key from-end test (start 0) end)
  122.             (t simple-string &rest t))
  123.   (unless (or (not test)
  124.           (continuation-function-is test char=-functions))
  125.     (give-up))
  126.   `(and (typep item 'character)
  127.     (,(if (constant-value-or-lose from-end)
  128.           'lisp::%sp-reverse-find-character
  129.           'lisp::%sp-find-character)
  130.      sequence start (or end (length sequence))
  131.      item)))
  132.  
  133.  
  134. (deftransform find ((item sequence &key from-end (test #'eql) (start 0) end)
  135.             (t simple-string &rest t))
  136.   `(if (position item sequence
  137.          ,@(when from-end `(:from-end from-end))
  138.          :test test :start start :end end)
  139.        item
  140.        nil))
  141.  
  142.  
  143. ;;;; Utilities:
  144.  
  145.  
  146. ;;; CONTINUATION-FUNCTION-IS  --  Interface
  147. ;;;
  148. ;;;    Return true if Cont's only use is a non-notinline reference to a global
  149. ;;; function with one of the specified Names.
  150. ;;;
  151. (defun continuation-function-is (cont names)
  152.   (declare (type continuation cont) (list names))
  153.   (let ((use (continuation-use cont)))
  154.     (and (ref-p use)
  155.      (let ((leaf (ref-leaf use)))
  156.        (and (global-var-p leaf)
  157.         (eq (global-var-kind leaf) :global-function)
  158.         (not (null (member (leaf-name leaf) names :test #'equal))))))))
  159.  
  160.  
  161. ;;; CONSTANT-VALUE-OR-LOSE  --  Interface
  162. ;;;
  163. ;;;    If Cont is a constant continuation, the return the constant value.  If
  164. ;;; it is null, then return default, otherwise quietly GIVE-UP.
  165. ;;; ### Probably should take an ARG and flame using the NAME.
  166. ;;;
  167. (defun constant-value-or-lose (cont &optional default)
  168.   (declare (type (or continuation null) cont))
  169.   (cond ((not cont) default)
  170.     ((constant-continuation-p cont)
  171.      (continuation-value cont))
  172.     (t
  173.      (give-up))))
  174.  
  175. #|
  176. ;;; MAKE-ARG, ARG-CONT, ARG-NAME  --  Interface
  177. ;;;
  178. ;;;    This is a frob whose job it is to make it easier to pass around the
  179. ;;; arguments to IR1 transforms.  It bundles together the name of the argument
  180. ;;; (which should be referenced in any expansion), and the continuation for
  181. ;;; that argument (or NIL if unsupplied.)
  182. ;;;
  183. (defstruct (arg (:constructor %make-arg (name cont)))
  184.   (name nil :type symbol)
  185.   (cont nil :type (or continuation null)))
  186. ;;;
  187. (defmacro make-arg (name)
  188.   `(%make-arg ',name ,name))
  189.  
  190. ;;; DEFAULT-ARG  --  Interface
  191. ;;;
  192. ;;;    If Arg is null or its CONT is null, then return Default, otherwise
  193. ;;; return Arg's NAME.
  194. ;;;
  195. (defun default-arg (arg default)
  196.   (declare (type (or arg null) arg))
  197.   (if (and arg (arg-cont arg))
  198.       (arg-name arg)
  199.       default))
  200.  
  201.  
  202. ;;; ARG-CONSTANT-VALUE  --  Interface
  203. ;;;
  204. ;;;    If Arg is null or has no CONT, return the default.  Otherwise, Arg's
  205. ;;; CONT must be a constant continuation whose value we return.  If not, we
  206. ;;; give up.
  207. ;;;
  208. (defun arg-constant-value (arg default)
  209.   (declare (type (or arg null) arg))
  210.   (if (and arg (arg-cont arg))
  211.       (let ((cont (arg-cont arg)))
  212.     (unless (constant-continuation-p cont)
  213.       (give-up "Argument is not constant: ~S." (arg-name arg)))
  214.     (continuation-value from-end))
  215.       default))
  216.  
  217.  
  218. ;;; ARG-EQL  --  Internal
  219. ;;;
  220. ;;;    If Arg is a constant and is EQL to X, then return T, otherwise NIL.  If
  221. ;;; Arg is NIL or its CONT is NIL, then compare to the default.
  222. ;;;
  223. (defun arg-eql (arg default x)
  224.   (declare (type (or arg null) x))
  225.   (if (and arg (arg-cont arg))
  226.       (let ((cont (arg-cont arg)))
  227.     (and (constant-continuation-p cont)
  228.          (eql (continuation-value cont) x)))
  229.       (eql default x)))
  230.  
  231.  
  232. (defstruct iterator
  233.   ;;
  234.   ;; The kind of iterator.
  235.   (kind nil (member :normal :result))
  236.   ;;
  237.   ;; A list of LET* bindings to create the initial state.
  238.   (binds nil :type list)
  239.   ;;
  240.   ;; A list of declarations for Binds.
  241.   (decls nil :type list)
  242.   ;;
  243.   ;; A form that returns the current value.  This may be set with SETF to set
  244.   ;; the current value.
  245.   (current (error "Must specify CURRENT."))
  246.   ;;
  247.   ;; In a :Normal iterator, a form that tests whether there is a current value.
  248.   (done nil)
  249.   ;;
  250.   ;; In a :Result iterator, a form that truncates the result at the current
  251.   ;; position and returns it.
  252.   (result nil)
  253.   ;;
  254.   ;; A form that returns the initial total number of values.  The result is
  255.   ;; undefined after NEXT has been evaluated.
  256.   (length (error "Must specify LENGTH."))
  257.   ;;
  258.   ;; A form that advances the state to the next value.  It is an error to call
  259.   ;; this when the iterator is Done.
  260.   (next (error "Must specify NEXT.")))
  261.  
  262.  
  263. ;;; Type of an index var that can go negative (in the from-end case.)
  264. (deftype neg-index ()
  265.   `(integer -1 ,most-positive-fixnum))
  266.  
  267.  
  268. ;;; MAKE-SEQUENCE-ITERATOR  --  Interface
  269. ;;;
  270. ;;;    Return an ITERATOR structure describing how to iterate over an arbitrary
  271. ;;; sequence.  Sequence is a variable bound to the sequence, and Type is the
  272. ;;; type of the sequence.  If true, INDEX is a variable that should be bound to
  273. ;;; the index of the current element in the sequence.
  274. ;;;
  275. ;;;    If we can't tell whether the sequence is a list or a vector, or whether
  276. ;;; the iteration is forward or backward, then GIVE-UP.
  277. ;;;
  278. (defun make-sequence-iterator (sequence type &key start end from-end index)
  279.   (declare (symbol sequence) (type ctype type)
  280.        (type (or arg null) start end from-end)
  281.        (type (or symbol null) index))
  282.   (let ((from-end (arg-constant-value from-end nil)))
  283.     (cond ((csubtypep type (specifier-type 'vector))
  284.        (let* ((n-stop (gensym))
  285.           (n-idx (or index (gensym)))
  286.           (start (default-arg 0 start))
  287.           (end (default-arg `(length ,sequence) end)))
  288.          (make-iterator
  289.           :kind :normal
  290.           :binds `((,n-idx ,(if from-end `(1- ,end) ,start))
  291.                (,n-stop ,(if from-end `(1- ,start) ,end)))
  292.           :decls `((type neg-index ,n-idx ,n-stop))
  293.           :current `(aref ,sequence ,n-idx)
  294.            :done `(,(if from-end '<= '>=) ,n-idx ,n-stop)
  295.           :next `(setq ,n-idx
  296.                ,(if from-end `(1- ,n-idx) `(1+ ,n-idx)))
  297.           :length (if from-end
  298.               `(- ,n-idx ,n-stop)
  299.               `(- ,n-stop ,n-idx)))))
  300.       ((csubtypep type (specifier-type 'list))
  301.        (let* ((n-stop (if (and end (not from-end)) (gensym) nil))
  302.           (n-current (gensym))
  303.           (start-p (not (arg-eql start 0 0)))
  304.           (end-p (not (arg-eql end nil nil)))
  305.           (start (default-arg start 0))
  306.           (end (default-arg end nil)))
  307.          (make-iterator
  308.           :binds `((,n-current
  309.             ,(if from-end
  310.                  (if (or start-p end-p)
  311.                  `(nreverse (subseq ,sequence ,start
  312.                             ,@(when end `(,end))))
  313.                  `(reverse ,sequence))
  314.                  (if start-p
  315.                  `(nthcdr ,start ,sequence)
  316.                  sequence)))
  317.                ,@(when n-stop
  318.                `((,n-stop (nthcdr (the index
  319.                            (- ,end ,start))
  320.                           ,n-current))))
  321.                ,@(when index
  322.                `((,index ,(if from-end `(1- ,end) start)))))
  323.           :kind :normal
  324.           :decls `((list ,n-current ,n-end)
  325.                ,@(when index `((type neg-index ,index))))
  326.           :current `(car ,n-current)
  327.           :done `(eq ,n-current ,n-stop)
  328.           :length `(- ,(or end `(length ,sequence)) ,start)
  329.           :next `(progn
  330.                (setq ,n-current (cdr ,n-current))
  331.                ,@(when index
  332.                `((setq ,n-idx
  333.                    ,(if from-end
  334.                     `(1- ,index)
  335.                     `(1+ ,index)))))))))
  336.       (t
  337.        (give-up "Can't tell whether sequence is a list or a vector.")))))
  338.  
  339.  
  340. ;;; MAKE-RESULT-SEQUENCE-ITERATOR  --  Interface
  341. ;;;
  342. ;;;    Make an iterator used for constructing result sequences.  Name is a
  343. ;;; variable to be bound to the result sequence.  Type is the type of result
  344. ;;; sequence to make.  Length is an expression to be evaluated to get the
  345. ;;; maximum length of the result (not evaluated in list case.)
  346. ;;;
  347. (defun make-result-sequence-iterator (name type length)
  348.   (declare (symbol name) (type ctype type))
  349.  
  350. ;;; COERCE-FUNCTIONS  --  Interface
  351. ;;;
  352. ;;;    Defines each Name as a local macro that will call the value of the
  353. ;;; Fun-Arg with the given arguments.  If the argument isn't known to be a
  354. ;;; function, give them an efficiency note and reference a coerced version.
  355. ;;;
  356. (defmacro coerce-functions (specs &body body)
  357.   "COERCE-FUNCTIONS ({(Name Fun-Arg Default)}*) Form*"
  358.   (collect ((binds)
  359.         (defs))
  360.     (dolist (spec specs)
  361.       `(let ((body (progn ,@body))
  362.          (n-fun (arg-name ,(second spec)))
  363.          (fun-cont (arg-cont ,(second spec))))
  364.      (cond ((not fun-cont)
  365.         `(macrolet ((,',(first spec) (&rest args)
  366.                  `(,',',(third spec) ,@args)))
  367.            ,body))
  368.            ((not (csubtypep (continuation-type fun-cont)
  369.                 (specifier-type 'function)))
  370.         (when (policy *compiler-error-context* (> speed brevity))
  371.           (compiler-note
  372.            "~S may not be a function, so must coerce at run-time."
  373.            n-fun))
  374.         (once-only ((n-fun `(if (functionp ,n-fun)
  375.                     ,n-fun
  376.                     (symbol-function ,n-fun))))
  377.           `(macrolet ((,',(first spec) (&rest args)
  378.                    `(funcall ,',n-fun ,@args)))
  379.              ,body)))
  380.            (t
  381.         `(macrolet ((,',(first spec) (&rest args)
  382.                   `(funcall ,',n-fun ,@args)))
  383.            ,body)))))))
  384.  
  385.  
  386. ;;; WITH-SEQUENCE-TEST  --  Interface
  387. ;;;
  388. ;;;    Wrap code around the result of the body to define Name as a local macro
  389. ;;; that returns true when its arguments satisfy the test according to the Args
  390. ;;; Test and Test-Not.  If both Test and Test-Not are supplied, abort the
  391. ;;; transform.
  392. ;;;
  393. (defmacro with-sequence-test ((name test test-not) &body body)
  394.   `(let ((not-p (arg-cont ,test-not)))
  395.      (when (and (arg-cont ,test) not-p)
  396.        (abort-transform "Both ~S and ~S supplied." (arg-name ,test)
  397.             (arg-name ,test-not)))
  398.      (coerce-functions ((,name (if not-p ,test-not ,test) eql))
  399.        ,@body)))
  400.  
  401. |#
  402.  
  403. ;;;; Hairy sequence transforms:
  404.  
  405.  
  406.  
  407. ;;;; String operations:
  408.  
  409. ;;; STRINGxxx transform  --  Internal
  410. ;;;
  411. ;;;    We transform the case-sensitive string predicates into a non-keyword
  412. ;;; version.  This is an IR1 transform so that we don't have to worry about
  413. ;;; changing the order of evaluation.
  414. ;;;
  415. (dolist (stuff '((string< string<*)
  416.          (string> string>*)
  417.          (string<= string<=*)
  418.          (string>= string>=*)
  419.          (string= string=*)
  420.          (string/= string/=*)))
  421.   (destructuring-bind (fun pred*) stuff
  422.     (deftransform fun ((string1 string2 &key (start1 0) end1
  423.                 (start2 0) end2)
  424.                '* '* :eval-name t)
  425.       `(,pred* string1 string2 start1 end1 start2 end2))))
  426.  
  427.  
  428. ;;; STRING-xxx* transform  --  Internal
  429. ;;;
  430. ;;;    Return a form that tests the free variables STRING1 and STRING2 for the
  431. ;;; ordering relationship specified by Lessp and Equalp.  The start and end are
  432. ;;; also gotten from the environment.  Both strings must be simple strings.
  433. ;;;
  434. (dolist (stuff '((string<* t nil)
  435.          (string<=* t t)
  436.          (string>* nil nil)
  437.          (string>=* nil t)))
  438.   (destructuring-bind (name lessp equalp) stuff
  439.     (deftransform name ((string1 string2 start1 end1 start2 end2)
  440.             '(simple-string simple-string t t t t) '*
  441.             :eval-name t)
  442.       `(let* ((end1 (if (not end1) (length string1) end1))
  443.           (end2 (if (not end2) (length string2) end2))
  444.           (index (lisp::%sp-string-compare
  445.               string1 start1 end1 string2 start2 end2)))
  446.      (if index
  447.          (cond ((= index ,(if lessp 'end1 'end2)) index)
  448.            ((= index ,(if lessp 'end2 'end1)) nil)
  449.            ((,(if lessp 'char< 'char>)
  450.              (schar string1 index)
  451.              (schar string2
  452.                 (truly-the index
  453.                        (+ index
  454.                       (truly-the fixnum
  455.                              (- start2 start1))))))
  456.             index)
  457.            (t nil))
  458.          ,(if equalp 'end1 'nil))))))
  459.  
  460.  
  461. (dolist (stuff '((string=* not)
  462.          (string/=* identity)))
  463.   (destructuring-bind (name result-fun) stuff
  464.     (deftransform name ((string1 string2 start1 end1 start2 end2)
  465.             '(simple-string simple-string t t t t) '*
  466.             :eval-name t)
  467.       `(,result-fun
  468.     (lisp::%sp-string-compare
  469.      string1 start1 (or end1 (length string1))
  470.      string2 start2 (or end2 (length string2)))))))
  471.